home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / TURB_VIS / TVISION / PUZZLE.PAS < prev    next >
Pascal/Delphi Source File  |  1990-10-23  |  7KB  |  302 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal 6.0                             }
  4. {   Turbo Vision Demo                            }
  5. {   Copyright (c) 1990 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. unit Puzzle;
  10.  
  11. {$F+,O+,S-,D-}
  12.  
  13. { Simple puzzle object. See TVDEMO.PAS for an example
  14.   program that uses this unit.
  15. }
  16.  
  17.  
  18. interface
  19.  
  20. uses views, Drivers, Objects, Crt;
  21.  
  22. const
  23.   CPuzzleView = #6#7;
  24.  
  25. type
  26.  
  27.  TBoard = array[0..5,0..5] of Char;
  28.  PPuzzleView = ^TPuzzleView;
  29.  TPuzzleView = object(TView)
  30.    Board: TBoard;
  31.    Moves: Word;
  32.    Solved: Boolean;
  33.    constructor Init(Bounds: TRect);
  34.    constructor Load(var S: TStream);
  35.    procedure HandleEvent(var Event: TEvent); Virtual;
  36.    procedure Draw; Virtual;
  37.    function  GetPalette: PPalette; virtual;
  38.    procedure MoveKey(Key: Word);
  39.    procedure MoveTile(Point: TPoint);
  40.    procedure Scramble;
  41.    procedure Store(var S: TStream);
  42.    procedure WinCheck;
  43.  end;
  44.  
  45.  PPuzzleWindow = ^TPuzzleWindow;
  46.  TPuzzleWindow = object(TWindow)
  47.    constructor Init;
  48.  end;
  49.  
  50. const
  51.   RPuzzleView: TStreamRec = (
  52.      ObjType: 10010;
  53.      VmtLink: Ofs(TypeOf(TPuzzleView)^);
  54.      Load:    @TPuzzleView.Load;
  55.      Store:   @TPuzzleView.Store
  56.   );
  57.   RPuzzleWindow: TStreamRec = (
  58.      ObjType: 10011;
  59.      VmtLink: Ofs(TypeOf(TPuzzleWindow)^);
  60.      Load:    @TPuzzleWindow.Load;
  61.      Store:   @TPuzzleWindow.Store
  62.   );
  63.  
  64. procedure RegisterPuzzle;
  65.  
  66. implementation
  67.  
  68. { TPuzzleWindow }
  69.  
  70. constructor TPuzzleWindow.Init;
  71. var
  72.   R: TRect;
  73. begin
  74.   R.Assign(1, 1, 21, 7);
  75.   TWindow.Init(R, 'Puzzle', 0);
  76.   Flags := Flags and not (wfZoom + wfGrow);
  77.   GrowMode := 0;
  78.   GetExtent(R);
  79.   R.Grow(-1, -1);
  80.   Insert(New(PPuzzleView, Init(R)));
  81. end;
  82.  
  83. { TPuzzleView }
  84.  
  85. constructor TPuzzleView.Init(Bounds: TRect);
  86. type
  87.   TBoardValue = array[1..16] of Char;
  88. const
  89.   SBoardValue: TBoardValue =
  90.     ('A','B','C','D',
  91.      'E','F','G','H',
  92.      'I','J','K','L',
  93.      'M','N','O',' ');
  94. var
  95.   I, J: Integer;
  96. begin
  97.   TView.Init(Bounds);
  98.   Randomize;
  99.   Options := Options or ofSelectable;
  100.   FillChar(Board, SizeOf(Board), '?');
  101.   for I := 0 to 3 do
  102.     for J := 0 to 3 do
  103.       Board[I+1, J+1] := SBoardValue[I*4 + J+1];
  104.   Scramble;
  105. end;
  106.  
  107. constructor TPuzzleView.Load(var S: TStream);
  108. begin
  109.   TView.Load(S);
  110.   S.Read(Board, SizeOf(Board) + Sizeof(Moves) + SizeOf(Solved));
  111. end;
  112.  
  113. Procedure TPuzzleView.Draw;
  114. var
  115.   I, J, K: Integer;
  116.   B: array[0..17] of word;
  117.   S1: String[3];
  118.   Color: array[0..1] of byte;
  119.   ColorBack: Byte;
  120. const
  121.   Map: array['A'..'O'] of Byte =
  122.     (0, 1, 0, 1,
  123.      1, 0, 1, 0,
  124.      0, 1, 0, 1,
  125.      1, 0, 1);
  126. begin
  127.   Color[0] := GetColor(1);
  128.   Color[1] := GetColor(2);
  129.   ColorBack := GetColor(1);
  130.   if Solved then Color[1] := Color[0]
  131.   else Color[1] := GetColor(2);
  132.   for I := 1 to 4 do
  133.   begin
  134.     MoveChar(B, ' ', ColorBack, 18);
  135.     if I = 2 then MoveStr(B[13], 'Move', ColorBack);
  136.     if I = 3 Then
  137.     begin
  138.       Str(Moves: 3, S1);
  139.       MoveStr(B[14], S1, ColorBack);
  140.     end;
  141.     for J := 1 to 4 do
  142.     begin
  143.       S1 := ' ' + Board[I, J] + ' ';
  144.       K := (Byte(Board[I, J]) mod 2) +1;
  145.       if Board[I, J] = ' ' then MoveStr(B[(J - 1) * 3], S1, Color[0])
  146.       else
  147.         MoveStr(B[(J - 1) * 3], S1, Color[Map[Board[I, J]]]);
  148.     end;
  149.     WriteLine(0, I - 1, 18, 1, B);
  150.   end;
  151. end;
  152.  
  153. function TPuzzleView.GetPalette: PPalette;
  154. const
  155.   P: String[Length(CPuzzleView)] = CPuzzleView;
  156. begin
  157.   GetPalette := @P;
  158. end;
  159.  
  160. procedure TPuzzleView.HandleEvent(var Event: TEvent);
  161. begin
  162.   TView.HandleEvent(Event);
  163.   if Solved and (Event.What and (evKeyDown + evMouseDown) <> 0) then
  164.   begin
  165.     Scramble;
  166.     ClearEvent(Event);
  167.   end;
  168.   case Event.What of
  169.     evMouseDown: MoveTile(Event.Where);
  170.     evKeyDown: MoveKey(Event.KeyCode);
  171.   else
  172.     Exit;
  173.   end;
  174.   ClearEvent(Event);
  175.   WinCheck;
  176. end;
  177.  
  178. procedure TPuzzleView.MoveKey(Key: Word);
  179. var
  180.   X, Y, I, J: Integer;
  181. begin
  182.   for I:=1 To 4 do
  183.     for J:=1 To 4 do
  184.       if Board[i,j] = ' ' then
  185.       begin
  186.         Y:=I;
  187.         X:=J;
  188.       end;
  189.  
  190.   case Key of
  191.     kbDown:
  192.       if Y > 1 then
  193.       begin
  194.         Board[Y, X] := Board[Y-1, X];
  195.         Board[Y-1, X] := ' ';
  196.         Inc(moves, Byte(moves<1000));
  197.       end;
  198.     kbUp:
  199.       if Y < 4 then
  200.       begin
  201.         Board[Y, X] := Board[Y+1, X];
  202.         Board[Y+1, X] := ' ';
  203.         Inc(moves, Byte(moves<1000));
  204.       end;
  205.     kbRight:
  206.       if X > 1 then
  207.       begin
  208.         Board[Y, X] := Board[Y, X-1];
  209.         Board[Y, X-1] := ' ';
  210.         Inc(moves, Byte(moves<1000));
  211.       end;
  212.     kbLeft:
  213.       if X < 4 then
  214.       begin
  215.         Board[Y, X] := Board[Y, X+1];
  216.         Board[Y, X+1] := ' ';
  217.         Inc(moves,Byte(moves<1000));
  218.       end;
  219.   end;
  220.   DrawView;
  221. end;
  222.  
  223. procedure TPuzzleView.MoveTile(Point: TPoint);
  224. var
  225.   P: TPoint;
  226.   X, Y: Word;
  227. begin
  228.   MakeLocal(Point, P);
  229.   X := ((P.X + 3) div 3);
  230.   Y := P.Y + 1;
  231.   if (X > 0) and (X < 5) and (Y > 0) and (Y < 5) Then
  232.   begin
  233.     if Board[Y, X-1] = ' ' then
  234.     begin
  235.       Board[Y, X-1] := Board[Y, X];
  236.       Board[Y, X] := ' ';
  237.       Inc(moves, Byte(moves<1000));
  238.     end;
  239.     if Board[Y-1, X] = ' ' then
  240.     begin
  241.       Board[Y-1, X] := Board[Y, X];
  242.       Board[Y, X] := ' ';
  243.       Inc(moves, Byte(moves<1000));
  244.     end;
  245.     if Board[Y, X+1] = ' ' then
  246.     begin
  247.       Board[Y, X+1] := Board[Y, X];
  248.       Board[Y, X] := ' ';
  249.       Inc(moves, Byte(moves<1000));
  250.     end;
  251.     if Board[Y+1, X] = ' ' then
  252.     begin
  253.       Board[Y+1, X] := Board[Y, X];
  254.       Board[Y, X] := ' ';
  255.       Inc(moves, Byte(moves<1000));
  256.     end;
  257.     DrawView;
  258.   end;
  259. end;
  260.  
  261. procedure TPuzzleView.Scramble;
  262. begin
  263.   Moves := 0;
  264.   Solved := False;
  265.   repeat
  266.     case Random(4) of
  267.       0: MoveKey(kbUp);
  268.       1: MoveKey(kbDown);
  269.       2: MoveKey(kbRight);
  270.       3: MoveKey(kbLeft);
  271.     end;
  272.   until Moves=500;
  273.   Moves := 0;
  274.   DrawView;
  275. end;
  276.  
  277. procedure TPuzzleView.Store(var S: TStream);
  278. begin
  279.   TView.Store(S);
  280.   S.Write(Board, SizeOf(Board) + Sizeof(Moves) + SizeOf(Solved));
  281. end;
  282.  
  283. procedure TPuzzleView.WinCheck;
  284. type
  285.   BoardStr = array [0..35] of Char;
  286. const
  287.   FBoard: BoardStr = '???????ABCD??EFGH??IJKL??MNO ???????';
  288. var
  289.   I: Integer;
  290. begin
  291.   Solved := BoardStr(Board) = FBoard;
  292.   DrawView;
  293. end;
  294.  
  295. procedure RegisterPuzzle;
  296. begin
  297.   RegisterType(RPuzzleView);
  298.   RegisterType(RPuzzleWindow);
  299. end;
  300.  
  301. end.
  302.